home *** CD-ROM | disk | FTP | other *** search
/ Info-Mac 1992 August / info-mac-1992.iso / Language (lang) / Lazy-Scheme / start < prev   
Text File  |  1978-01-04  |  3KB  |  103 lines
  1. (define (system:quasiquote s)
  2.    (cond (null? s) ()
  3.          (atom? s) (list 'quote s)
  4.          (eq? (0 s) 'unquote) (1 s)
  5.          (cons? (0 s)) (cond (eq? (0 (0 s)) 'unquote-splicing)
  6.                                  (if (null? (-1 s)) (1 (0 s))
  7.                                      (list 'append (1 (0 s)) (system:quasiquote (-1 s))))
  8.                                 † (list 'cons (system:quasiquote (0 s))
  9.                                               (system:quasiquote (-1 s))))
  10.          † (list 'cons (system:quasiquote (0 s))
  11.                        (system:quasiquote (-1 s)))))
  12.  
  13. (defmacro (quasiquote s) (system:quasiquote s))
  14. (defmacro (unquote | s) 'unquote)
  15. (defmacro (unquote-splicing | s) 'unquote-splicing)
  16.  
  17. (defmacro (defext fic seg nom xref str | arg)
  18.   `(begin (define (,nom ,@arg))
  19.           (coerce ,nom 13)
  20.           (force (car=! ,nom (getext ,xref ,seg ,fic)))
  21.           (coerce ,nom 12)
  22.           (setstrict ,nom ,str) ',nom))
  23.  
  24. (defmacro (kappa | l)
  25.   `(setstrict (lambda ,@l) %1111111111111111))
  26.  
  27. (defmacro (defkap f | b)
  28.   (cond (cons? f) `(define ,(0 f) (setstrict (lambda ,(-1 f) ,@b) %1111111111111111))
  29.         `(define ,f ,@b)))
  30.  
  31. (define (append l1 l2)
  32.       (cond (null? l1) l2
  33.             (cons (0 l1) (append (-1 l1) l2))))
  34.  
  35. (define (reverse l | bag)
  36.       (cond (null? l) bag
  37.             (apply reverse (cons (-1 l)(cons (0 l) bag)))))
  38.  
  39. (defkap (memq? o l)
  40.    (cond (null? l) ƒ
  41.          (eq? o (0 l)) l
  42.          (memq? o (-1 l))))
  43.  
  44. (defkap (mem=? o l)
  45.    (cond (null? l) ƒ
  46.          (=? o (0 l)) l
  47.          (mem=? o (-1 l))))
  48.  
  49. (defkap (equal? l1 l2)
  50.   (cond (=? l1 l2) †
  51.         (cons? l1)(and (cons? l2)(equal? (0 l1)(0 l2))(equal? (-1 l1)(-1 l2)))))
  52.  
  53. (defkap (member? o l)
  54.    (cond (null? l) ƒ
  55.          (equal? o (0 l)) l
  56.          (member? o (-1 l))))
  57.  
  58. (defkap (nequal? l1 l2)
  59.   (not (equal? l1 l2)))
  60.  
  61. (defkap (union l1 l2)
  62.     (cond (<? (0 l1)(0 l2))(cons (0 l1) (union (-1 l1) l2))
  63.           (=? (0 l1)(0 l2))(cons (0 l1)(union (-1 l1)(-1 l2)))
  64.           (cons (0 l2) (union l1 (-1 l2)))))
  65.  
  66. (defkap (inter l1 l2)
  67.     (cond (<? (0 l1)(0 l2)) (inter (-1 l1) l2)
  68.           (=? (0 l1)(0 l2))(cons (0 l1)(inter (-1 l1)(-1 l2)))
  69.           (inter l1 (-1 l2))))
  70.  
  71. (defkap (diff l1 l2)
  72.      (cond (=? (0 l1)(0 l2)) (diff (-1 l1) l2)
  73.            (<? (0 l1)(0 l2)) (cons (0 l1) (diff (-1 l1) l2))
  74.           (diff l1 (-1 l2))))
  75.  
  76. (define (map f | l)
  77.  (amap f l))
  78.  
  79. (defkap (amap f l)
  80.  (cond (atom? f)(apply f l)
  81.        (cons (amap (0 f) (allcar l))
  82.                    (amap (-1 f) (allcdr l)))))
  83.  
  84. (defkap (allcar l)
  85.   (cond (null? l) ()
  86.         (cons (0 (0 l)) (allcar (-1 l)))))
  87.  
  88. (defkap (allcdr l)
  89.   (cond (null? l) ()
  90.         (cons (-1(0 l)) (allcdr (-1 l)))))
  91.  
  92. (define (consif kar kdr)
  93.   (cond kar (cons kar kdr)
  94.         kdr))
  95.  
  96. (define (reduce f b l)
  97.    (cond (null? l) b
  98.          (f (0 l) (reduce f b (-1 l)))))
  99.          
  100. (define (suchas p f)
  101.   (cond (p (0 f)) (cons (0 f) (suchas p (-1 f)))
  102.         (suchas p (-1 f))))
  103.